Chip 1998 September/CHIP Eylül 1998.iso/freeware/Memct00/memct.exe/MemCtrl.pas

Pascal/Delphi Source File | 1998-03-17 | 6KB | 244 lines

unit MemCtrl;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, extctrls, dsgnintf;

type
  TAboutProperty = class(TPropertyEditor)
  public
    procedure Edit; override;
    function GetAttributes: TPropertyAttributes; override;
    function GetValue: string; override;
  end;

type
  TMemShow = (
    TotalAddrSpace, TotalUncommitted, TotalCommitted,
    TotalAllocated, TotalFree, FreeSmall, FreeBig,
    Unused, Overhead, HeapErrorCode
  );

  TMemShows = set of TMemShow;

type
  TMemCtrl = class(TGraphicControl)
  private
    FAbout : TAboutProperty;
    FAutoSize : Boolean;
    FMemCnt : Integer;
    FMemStr : Array[0..10] of string[50];
    FMemStr_Old : Array[0..10] of string[50];
    FFont      : TFont;
    FHeap  : THeapStatus;
    FTimer : TTimer;
    FInterval : Cardinal;
    FMemShows : TMemShows;
    FPolling  : Boolean;
    procedure SetPolling(A : Boolean);
    procedure SetInterval(A : Cardinal);
    procedure SetFont(A : TFont);
    procedure SetAutoSize(A : Boolean);
    procedure TimerFunc(Sender: TObject);
  protected
    procedure Paint; override;
  public
    constructor create(AOwner : TComponent); override;
    destructor  destroy; override;
  published
    property About : TAboutProperty read FAbout write FAbout;
    property MemShows : TMemShows read FMemShows write FMemShows;
    property Interval : Cardinal read FInterval write SetInterval;
    property Polling  : Boolean  read FPolling  write SetPolling;
    property Font: TFont read FFont write SetFont;
    property AutoSize : Boolean read FAutoSize write SetAutoSize;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Lib_Erw', [TMemCtrl]);
  RegisterPropertyEditor(TypeInfo(TAboutProperty), TMemCtrl,
                         'ABOUT', TAboutProperty);

end;

procedure TAboutProperty.Edit;
begin
  Application.MessageBox ('TMemCtrl by kbi'            + #13#10 +
                          'This component is freeware.' + #13#10 +
                          '⌐ 1998 kbi'                  + #13#10 +
                          'mailto:[e-mail]',
                          'About',
                          MB_OK + MB_ICONINFORMATION);
end;

function TAboutProperty.GetAttributes: TPropertyAttributes;
begin
  Result := [paMultiSelect, paDialog, paReadOnly];
end;

function TAboutProperty.GetValue: string;
begin
  Result := 'About';
end;



procedure TMemCtrl.SetInterval(A : Cardinal);
begin
  FInterval := A;
  FTimer.Interval := A;
end;

procedure TMemCtrl.SetPolling(A : Boolean);
begin
  FPolling := A;
  FTimer.enabled := A;
end;

procedure TMemCtrl.TimerFunc(Sender: TObject);
var
  topaint : Boolean;
  k : integer;
begin
  topaint := false;

  FHeap := GetHeapStatus;
  FTimer.enabled := false;

  FMemCnt := 0;
  if TotalAddrSpace in FMemShows then
  begin
    FMemStr[FMemCnt] := 'TotalAddrSpace: ' + inttostr(FHeap.TotalAddrSpace);
    inc(FMemCnt);
  end;
  if TotalUncommitted in FMemShows then
  begin
    FMemStr[FMemCnt] := 'TotalUncommitted: ' + inttostr(FHeap.TotalUncommitted);
    inc(FMemCnt);
  end;
  if TotalCommitted in FMemShows then
  begin
    FMemStr[FMemCnt] := 'TotalCommitted: ' + inttostr(FHeap.TotalUncommitted);
    inc(FMemCnt);
  end;
  if TotalAllocated in FMemShows then
  begin
    FMemStr[FMemCnt] := 'TotalAllocated: ' + inttostr(FHeap.TotalAllocated);
    inc(FMemCnt);
  end;
  if TotalFree in FMemShows then
  begin
    FMemStr[FMemCnt] := 'TotalFree: ' + inttostr(FHeap.TotalFree);
    inc(FMemCnt);
  end;
  if FreeSmall in FMemShows  then
  begin
    FMemStr[FMemCnt] := 'FreeSmall: ' + inttostr(FHeap.TotalFree);
    inc(FMemCnt);
  end;
  if FreeBig in FMemShows then
  begin
    FMemStr[FMemCnt] := 'FreeBig: ' + inttostr(FHeap.FreeBig);
    inc(FMemCnt);
  end;
  if Unused in FMemShows then
  begin
    FMemStr[FMemCnt] := 'Unused: ' + inttostr(FHeap.Unused);
    inc(FMemCnt);
  end;
  if Overhead in FMemShows then
  begin
    FMemStr[FMemCnt] := 'Overhead: ' + inttostr(FHeap.Overhead);
    inc(FMemCnt);
  end;
  if Overhead in FMemShows then
  begin
    FMemStr[FMemCnt] := 'HeapErrorCode: ' + inttostr(FHeap.HeapErrorCode);
    inc(FMemCnt);
  end;
  for k := 0 to FMemCnt-1  do
  begin
    if FMemStr_Old[k] <> FMemStr[k] then topaint := true;
    FMemStr_Old[k] := FMemStr[k];
  end;

  if topaint then paint;
  FTimer.enabled :=Polling;
end;


constructor TMemCtrl.create(AOwner : TComponent);
begin
  inherited create(AOwner);
  FFont          := TFont.create;
  FTimer := TTimer.Create(self);
  FTimer.interval := 200;
  FTimer.OnTimer := TimerFunc;
  FAutoSize := true;
  MemShows := [TotalAllocated];
  Polling  := true;
  Interval := 200;
end;

destructor TMemCtrl.destroy;
begin
  FTimer.free;
  FFont.free;
  inherited;
end;

procedure TMemCtrl.SetFont(A : TFont);
begin
  if A <> FFont then
  begin
    FFont.Assign(A);
    Canvas.Font := FFont;
    invalidate;
  end;
end;

procedure TMemCtrl.SetAutoSize(A : Boolean);
begin
  if A <> FAutoSize then
  begin
    FAutoSize := A;
    invalidate;
  end;
end;

procedure TMemCtrl.Paint;
var
  h, w, k : integer;
begin
  h := 0; w := 0;
  for k := 0 to FMemCnt-1  do
  begin
    if canvas.TextHeight(FMemStr[k]) > h then
      h := canvas.TextHeight(FMemStr[k]);
    if canvas.TextWidth(FMemStr[k]) > w then
      w := canvas.TextWidth(FMemStr[k]);
  end;
  if FAutoSize then
  begin
    Height := FMemCnt*h+4;
    Width  := w+4;
  end;
  canvas.pen.style := psclear;
  canvas.rectangle(0,0,w+4, (FMemCnt)*h+4);
  canvas.pen.style := pssolid;
  for k := 0 to FMemCnt-1  do
    canvas.textout(1,k*h, FMemStr[k]);
end;




end.